(module lang
  (lib "eopl.ss" "eopl")                
  
  ;  (require "drscheme-init.scm")
  
  (provide (all-defined))

  ;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;;
  
  (define the-lexical-spec
    '((whitespace (whitespace) skip)
      (comment ("%" (arbno (not #\newline))) skip)
      (identifier
        (letter (arbno (or letter digit "_" "-" "?")))
        symbol)
      (number (digit (arbno digit)) number)
      (number ("-" digit (arbno digit)) number)
      ))

  (define the-grammar

    '(
      
      ;; here we implicitly construct the manifest from the list of
      ;; module definitions.

      ;; the main program still explicitly imports the modules it needs.

      (program
        ((arbno interface-definition)
         (arbno module-definition)
         (arbno "import" identifier)
         expression)
        a-program)


      (interface-definition
        ("interface" identifier "=" module-type)
        an-interface-definition)

      (module-definition
        ("module" identifier 
          "interface" module-type
          "implementation"
           (arbno "import" identifier)
           module-body)
        a-module-definition)


      ;; used for named signatures, which we're going to leave out of this
      ;; version. 
;;       (module-type
;;         (identifier)
;;         named-module-type)

      (module-type
        ("[" (arbno declaration) "]") 
        env-module-type)

      (module-type
        ("(" "(" identifier ":" module-type ")" "=>" module-type ")") 
        proc-module-type)


;;       (import-command
;;         ("import" identifier)
;;         an-import-command)


      (declaration
        ("abstract-type" identifier)
        abstract-type-declaration)

      (declaration
        ("type-abbrev" identifier "=" type)
        type-abbrev-declaration)

      (declaration    
        (identifier ":" type)
        val-declaration)



      (module-body
        ("[" (arbno definition) "]")
        defns-module-body)

      (module-body
        ("module-proc" "(" identifier ":" module-type ")" module-body)
        proc-module-body)

      (module-body
        (identifier)
        var-module-body)

      (module-body
        ("(" identifier identifier ")")
        module-app-module-body)

      (definition
        (identifier "=" expression)
        val-definition)

      (definition
        ("type" identifier "=" type)
        type-definition)

      ;; expression::= "from" M "take" var     --qualified reference

      (expression
        ("from" identifier "take" identifier)
        qualified-var-ref)

      ;; new types

      (type
        (identifier)
        named-type)                

      (type
        ("from" identifier "take" identifier)
        qualified-type)

 
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;; no changes in grammar below here
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

      (expression (number) const-exp)

      (expression
        ("-" "(" expression "," expression ")")
        diff-exp)
      
      (expression
        ("zero?" "(" expression ")")
        zero?-exp)

      (expression
        ("if" expression "then" expression "else" expression)
        if-exp)

      (expression (identifier) var-exp)

      (expression
        ("let" identifier "=" expression "in" expression)
        let-exp)   

      (expression
        ("proc" "(" identifier ":" optional-type ")" expression)
        proc-exp)

      (expression
        ("(" expression expression ")")
        call-exp)

      (expression
        ("letrec"
          optional-type identifier "(" identifier ":" optional-type ")"
          "=" expression "in" expression)
        letrec-exp)

      (optional-type
        ("?")
        no-type)
      
      (optional-type
        (type)
        a-type)

      (type
        ("int")
        int-type)
      
      (type
        ("bool")
        bool-type)
      
      (type
        ("(" type "->" type ")")
        proc-type)

      (type
        ("%tvar-type" number)
        tvar-type)

      ))
  
  ;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;;
  
  (sllgen:make-define-datatypes the-lexical-spec the-grammar)
  
  (define show-the-datatypes
    (lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar)))
  
  (define scan&parse
    (sllgen:make-string-parser the-lexical-spec the-grammar))
  
  (define just-scan
    (sllgen:make-string-scanner the-lexical-spec the-grammar))

  ;;;;;;;;;;;;;;;; syntactic tests and observers ;;;;;;;;;;;;;;;;

  ;;;; for types

  (define atomic-type?
    (lambda (ty)
      (cases type ty
        (proc-type (ty1 ty2) #f)
        (tvar-type (sn) #f)
        (else #t))))

  (define proc-type?
    (lambda (ty)
      (cases type ty
        (proc-type (t1 t2) #t)
        (else #f))))

  (define tvar-type?
    (lambda (ty)
      (cases type ty
        (tvar-type (serial-number) #t)
        (else #f))))

  (define proc-type->arg-type
    (lambda (ty)
      (cases type ty
        (proc-type (arg-type result-type) arg-type)
        (else (eopl:error 'proc-type->arg-type
                "Not a proc type: ~s" ty)))))

  (define proc-type->result-type
    (lambda (ty)
      (cases type ty
        (proc-type (arg-type result-type) result-type)
        (else (eopl:error 'proc-type->result-types
                "Not a proc type: ~s" ty)))))

  (define type-to-external-form
    (lambda (ty)
      (cases type ty
        (int-type () 'int)
        (bool-type () 'bool)
        (proc-type (arg-type result-type)
          (list
            (type-to-external-form arg-type)
            '->
            (type-to-external-form result-type)))
       (named-type (name) name)
        (qualified-type (modname varname)
          (list 'from modname 'take varname))
        (tvar-type (serial-number)
          (string->symbol
            (string-append
              "tvar%"
              (number->string serial-number)))))))
  
;;   (define import-command->import
;;     (lambda (i-cmd)
;;       (cases import-command i-cmd
;;         (an-import-command (name) name))))


;;   (define import-commands->imports
;;     (lambda (import-cmds)
;;       (map import-command->import import-cmds)))

  ;;;; for module definitions

  ;; sym * (list-of module-definition) -> (maybe module-definition)
  (define maybe-lookup-module-in-list
    (lambda (name module-defs)
      (if (null? module-defs)
        #f
        (let ((name1 (module-definition->name (car module-defs))))
          (if (eqv? name1 name)
            (car module-defs)
            (maybe-lookup-module-in-list name (cdr module-defs)))))))

  (define lookup-module-in-list
    (lambda (name module-defs)
      (cond
        ((maybe-lookup-module-in-list name module-defs)
         => (lambda (mdef) mdef))
        (else 
          (eopl:error 'lookup-module-in-list
            "unknown module ~s"
            name)))))

  (define module-definition->name
    (lambda (m-defn)
      (cases module-definition m-defn
        (a-module-definition (m-name m-type imports m-body)
          m-name))))

  (define module-definition->imports
    (lambda (m-defn)
      (cases module-definition m-defn
        (a-module-definition (m-name m-type imports m-body)
          imports))))

 (define module-definition->module-type
    (lambda (m-defn)
      (cases module-definition m-defn
        (a-module-definition (m-name m-type imports m-body)
          m-type))))

 (define val-decl?
   (lambda (decl)
     (cases declaration decl
       (val-declaration (name ty) #t)
       (else #f))))

 (define type-abbrev-decl?
   (lambda (decl)
     (cases declaration decl
       (type-abbrev-declaration (name ty) #t)
       (else #f))))

 (define abstype-decl?
   (lambda (decl)
     (cases declaration decl
       (abstract-type-declaration (name) #t)
       (else #f))))

 (define decl->name
   (lambda (decl)
     (cases declaration decl
       (abstract-type-declaration (name) name)
       (type-abbrev-declaration (name ty) name)
       (val-declaration (name ty) name))))

 (define decl->type
   (lambda (decl)
     (cases declaration decl
       (type-abbrev-declaration (name ty) ty)
       (val-declaration (name ty) ty)
       (abstract-type-declaration (name)
         (eopl:error 'decl->type
           "can't take type of abstract type declaration ~s"
           decl)))))
     

  )